home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / user-instances.lsp < prev    next >
Text File  |  1992-09-03  |  29KB  |  685 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*-
  2.  
  3. ;;;
  4. ;;; *************************************************************************
  5. ;;;
  6. ;;;   File: user-instances.lisp.
  7. ;;;
  8. ;;;     by Trent E. Lange, Effective Date 06-02-92
  9. ;;;
  10. ;;;
  11. ;;;  This file contains a metaclass (User-Vector-Class) whose instances
  12. ;;; are stored as simple-vectors, saving space over PCL's standard instance
  13. ;;; representations of PCL at the cost of some class redefinition flexibiliity.
  14. ;;;
  15. ;;; Permission is granted to any individual or institution to use, copy,
  16. ;;; modify and distribute this document.
  17. ;;;
  18. ;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu
  19. ;;; *************************************************************************
  20. ;;;
  21.  
  22. (in-package 'pcl)
  23.  
  24. ;;;   This file builds on the PCL-USER-INSTANCES feature of July 92 PCL
  25. ;;; to define the USER-VECTOR-CLASS metaclass whose instances are simple
  26. ;;; vectors.  The first element of the instance vector is the instance's
  27. ;;; class wrapper (providing internal PCL information about the instance's
  28. ;;; class).  The remaining elements of the instance vector are the instance's
  29. ;;; slots themselves.
  30. ;;;
  31. ;;;   The space overhead of user-vector-instances is only two vector cells
  32. ;;; (one for the vector, one for the wrapper).  This is contrast to standard
  33. ;;; PCL instances, which have a total overhead of four cells.  (Standard
  34. ;;; instances in PCL are represented as instances of structure STD-INSTANCE
  35. ;;; having two slots, one for the wrapper and one holding a simple-vector
  36. ;;; which is the instance's slots).  This two-cell space savings per instance
  37. ;;; comes at the cost of losing some class redefinition flexibility, since
  38. ;;; simple-vectors cannot have their sizes changed dynamically.
  39. ;;; All current instances of user-instance-vectors therefore become
  40. ;;; permanently obsolete if the classes' instance slots change.
  41. ;;;
  42. ;;;   This code requires July 92 PCL or later compiled with the
  43. ;;; PCL-USER-INSTANCES feature turned on (see PCL's low.lisp file).
  44. ;;;
  45.  
  46. #-pcl-user-instances
  47. (eval-when (compile load eval)
  48. (error "Cannot use user-instances, since PCL was compiled without
  49.         PCL-USER-INSTANCES on the *features* list (see pcl file low.lisp.)")
  50. )
  51.  
  52. (eval-when (compile load eval)
  53. (defclass user-vector-class-mixin () ()
  54.   (:documentation
  55.     "Use this mixin for metaclasses whose instances are USER-INSTANCES
  56.      instantiated as simple-vectors.  This saves space over the standard
  57.      instances used by standard-class, at the cost of losing the ability to
  58.      redefine the slots in a class and still have old instances updated correctly."))
  59.  
  60. (defclass user-vector-class (user-vector-class-mixin standard-class) ()
  61.   (:documentation
  62.     "A metaclass whose instances are USER-INSTANCES instantiated as simple-vectors.
  63.      This saves space over the standard instances used by standard-class, at the
  64.      cost of losing the ability to redefine the slots in a class and still have old
  65.      instances updated correctly."))
  66.  
  67. (defmethod validate-superclass ((class user-vector-class-mixin)
  68.                                 (new-super T))
  69.   (or (typep new-super 'user-vector-class-mixin)
  70.       (eq new-super (find-class 'standard-object))))
  71.  
  72. (defclass user-vector-object (standard-object) ()
  73.   (:metaclass user-vector-class))
  74. )
  75.  
  76. ;;;
  77. ;;;
  78. ;;; Instance allocation stuff.
  79. ;;;
  80.  
  81. (defmacro user-vector-instance-p (object)
  82.   (once-only (object)
  83.     `(the boolean
  84.           (and (simple-vector-p ,object)
  85.                (plusp (length (the simple-vector ,object)))
  86.                (wrapper-p (%svref ,object 0))))))
  87.  
  88. (defmacro user-vector-instance-wrapper (object)
  89.   `(%svref ,object 0))
  90.  
  91. (defsetf user-vector-instance-wrapper (object) (new-value)
  92.   `(setf (%svref ,object 0) ,new-value))
  93.  
  94. (defmacro user-vector-instance-slots (instance)
  95.   ;; The slots vector of user-vector instances is the instance itself.
  96.   instance)
  97.  
  98. (defmacro set-user-vector-instance-slots (instance new-value)
  99.   `(progn
  100.      (warn "Attempt to set user-vector-instance-slots of ~S to ~S"
  101.            ,instance ,new-value)
  102.      ,new-value))
  103.  
  104. (defun user-instance-p (x)
  105.   "Is X a user instance, specifically a user-vector-instance?"
  106.   (user-vector-instance-p x))
  107.  
  108. (defun user-instance-slots (x)
  109.   "Return the slots of this user-vector-instance."
  110.   (user-vector-instance-slots x))
  111.  
  112. (defun user-instance-wrapper (x)
  113.   "Return the wrapper of this user-vector-instance."
  114.   (user-vector-instance-wrapper x))
  115.  
  116. (defun set-user-instance-wrapper (x new)
  117.   (setf (user-vector-instance-wrapper x) new))
  118.  
  119. (defmacro get-user-instance-p (x)
  120.   `(user-vector-instance-p ,x))
  121.  
  122. (defmacro get-user-instance-wrapper (x)
  123.   `(user-vector-instance-wrapper ,x))
  124.  
  125. (defmacro get-user-instance-slots (x)
  126.   `(user-vector-instance-slots ,x))
  127.  
  128. (eval-when (eval #+cmu load)
  129.   (force-compile 'user-instance-p)
  130.   (force-compile 'user-instance-slots)
  131.   (force-compile 'user-instance-wrapper)
  132.   (force-compile 'set-user-instance-wrapper))
  133.  
  134.  
  135. ;;;
  136. ;;; Methods needed for user-vector-class-mixin.
  137. ;;;
  138.  
  139. (defconstant *not-a-slot* (gensym "NOT-A-SLOT"))
  140.  
  141. (defmethod allocate-instance ((class user-vector-class-mixin) &rest initargs)
  142.   (declare (ignore initargs))
  143.   (unless (class-finalized-p class) (finalize-inheritance class))
  144.   (let* ((class-wrapper (class-wrapper class))
  145.          (copy-instance (wrapper-allocate-static-slot-storage-copy
  146.                            class-wrapper))
  147.          (instance      (copy-simple-vector copy-instance)))
  148.     (declare (type simple-vector copy-instance instance))
  149.     (setf (user-vector-instance-wrapper instance) class-wrapper)
  150.     instance))
  151.  
  152. (defmethod make-instances-obsolete ((class user-vector-class-mixin))
  153.   "The slots of user-vector-instances are stored in the instance vector
  154.    themselves (a simple-vector), so old instances cannot be updated properly."
  155.   (setf (slot-value class 'prototype) NIL)
  156.   (warn "Obsoleting user-vector class ~A, all current instances will be invalid..."
  157.         class))
  158.  
  159. (defmethod compute-layout :around ((class user-vector-class-mixin)
  160.                                     cpl instance-eslotds)
  161.   ;; First element of user-vector-instance is actually its wrapper.
  162.   (declare (ignore cpl instance-eslotds))
  163.   (cons *not-a-slot* (call-next-method)))
  164.  
  165. (defmethod compute-instance-layout :around ((class user-vector-class-mixin)
  166.                                             instance-eslotds)
  167.   ;; First element of user-vector-instance is actually its wrapper.
  168.   (declare (ignore instance-eslotds))
  169.   (cons *not-a-slot* (call-next-method)))
  170.  
  171. (defmethod wrapper-fetcher ((class user-vector-class-mixin))
  172.   'user-vector-instance-wrapper)
  173.  
  174. (defmethod slots-fetcher ((class user-vector-class-mixin))
  175.   'user-vector-instance-slots)
  176.  
  177. (defmethod raw-instance-allocator ((class user-vector-class-mixin))
  178.   'allocate-user-vector-instance)
  179.  
  180.  
  181. ;;; Inform PCL that it is still safe to use its standard slot-value
  182. ;;; optimizations with user-vector-class-mixin's slot-value-using-class
  183. ;;; methods:
  184.  
  185. (pushnew
  186.   '(user-vector-class-mixin standard-object standard-effective-slot-definition)
  187.    *safe-slot-value-using-class-specializers*)
  188.  
  189. (pushnew
  190.   '(T user-vector-class-mixin standard-object standard-effective-slot-definition)
  191.    *safe-set-slot-value-using-class-specializers*)
  192.  
  193. (pushnew
  194.   '(user-vector-class-mixin standard-object standard-effective-slot-definition)
  195.   *safe-slot-boundp-using-class-specializers*)
  196.  
  197. (defmethod slot-value-using-class
  198.   ((class user-vector-class-mixin)
  199.    (object standard-object)
  200.    (slotd standard-effective-slot-definition))
  201.   (let* ((location (slot-definition-location slotd))
  202.      (value
  203.            (typecase location
  204.           (fixnum
  205.                 (%svref (user-vector-instance-slots object) location))
  206.           (cons
  207.             (cdr location))
  208.           (t
  209.            (error
  210.                  "The slot ~s has neither :instance nor :class allocation, ~@
  211.                               so it can't be read by the default ~s method."
  212.           slotd 'slot-value-using-class)))))
  213.     (if (eq value *slot-unbound*)
  214.